# $Id$
# Copyright (c) 2012, Prabhu Gurumurthy
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# Redistributions of source code must retain the above copyright notice, this
# list of conditions and the following disclaimer.
#
# Redistributions in binary form must reproduce the above copyright notice, this
# list of conditions and the following disclaimer in the documentation and/or
# other materials provided with the distribution.
#
# Neither the name of the "Any company that I work for" nor the names of its
# contributors may be used to endorse or promote products derived from this
# software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# __version__  = "$Revision$"
# __author__   = "$Author$"
# __modified__ = "$Date$"

# Exporting functions and global variable being set
namespace eval netaddr {
   namespace export ip
   namespace export getversion
   namespace export getaddress
   namespace export getnetattr
   namespace export getmask
   namespace export getwildcard
   namespace export pton
   namespace export ntop
   namespace export contains
   namespace export ip2integer
   namespace export getsize
   namespace export getbroadcast
   namespace export ifscope
   namespace export completeip

   variable version 
   variable _ipver
   variable _ipaddr
   variable _ipsubnet
   variable _ipint
   variable _completeaddr
   variable _ipmask
   variable _ipnet
   variable _ipwcard
   variable _ipsize
   variable _ipnetwork
   variable _ifscope

   set version 1.0
}

# Maximum IPv4 integer value
set maxinteger [expr round(pow(2,32))]

# Maximum IPv6 integer value
set maxlong [expr round(pow(2,128))]

# Utility function used for IPv6 to integer conversion
proc netaddr::_hex2int value {
   set retval 0
   scan $value %x retval
   return $retval
}

proc netaddr::_error mesg {
   if {[string length $mesg] > 0} {
      return -code error -errorinfo $mesg -errorcode 1
   } else {
      return -code error -errorinfo "Unknown error" -errorcode -1
   }
}

proc netaddr::_warn mesg {
   if {[string length $mesg]} {
      puts $mesg
   }
}

# Function used to verify integrity of an IPv6 address
proc netaddr::_checkv6 address {
   set octets [split $address :]
   set retval 1
   if {[llength $octets] < 3 || [llength $octets] > 8} {
      set retval 0
   } else {
      set index 0
      foreach octet $octets {
         incr index
         if {[string length $octet] < 1} { continue }
         if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} { continue }
         if {[catch {[expr int(0x$octet)] < 65535} err]} {
            netaddr::_error $err
         } else {
            if {[string length $octet] > 4} {
               set retval 0
               break
            }
            continue
         }
         set retval 0
      }

      if {$retval && [regexp {^:[^:]} $address]} {
         set retval 0
      }

      if {$retval && [regexp {[^:]:$} $address]} {
         set retval 0
      }

      if {$retval && [regsub -all :: $address "|" temp] > 1} {
         set retval 0
      }

      set dcolon [regexp -all {:{2}} $address]
      set tcolon [regexp -all {:{3}} $address]

      if {$dcolon > 1 || $tcolon == 1} {
         if {$retval} { set retval 0 }
      }
   }

   return $retval
}

# Normalize IPv4/IPv6 in that way the expanded IP is being used in calculation 
# instead of abbreviated form
# Example: 172.29.17/24 would be normalized to 172.29.17.0/24
# Same for IPv6, 2001:1868:209:fffd::/64 would be normalized to
#                2001:1868:209:fffd:0000:0000:0000:0000/64
proc netaddr::_normalize { address { version 0 }} {
   set temp [list]
   set retval ""

   if {$version == 4} {
      set count 0
      foreach octet [split $address "."] {
         incr count
         if {$count <= 4 && $count > 0} {
            if {$octet < 0 || $octet > 255} {
               netaddr::_error "Invalid $count octet: $octet"
               exit 1
            } else {
               lappend temp $octet
            }
         } else {
            netaddr::_error "Invalid ip address $address"
         }
      }

      if {$count < 4} {
         set maxval 4
         for {set ix [llength $temp]} { $ix < $maxval} {incr ix} {
            lappend temp 0
         }

         set retval [join $temp "."]
      } elseif {$count == 4} {
         set retval $address
      }
   } elseif {$version == 6} {
      if {[netaddr::_checkv6 $address]} {
         set octets [split $address :]
         set octlen [llength $octets]
         set octval [expr 8 - [expr $octlen - 1]]
         set lastoct [lindex $octets end]
         if {$octlen < 8} {
            set index 1
            foreach octet $octets {
               set olen [string length $octet]
               set maxoct [expr $olen % 4]
               if {$olen} {
                  if {$maxoct == 0} {
                     lappend temp $octet
                  } else {
                     set jy [expr 4 - $maxoct]
                     set val ""
                     for {set ix 0} {$ix < $jy} {incr ix} {
                        set val [format "%s0" $val]
                     }

                     set val [concat "$val$octet"]
                     lappend temp $val
                  }
               } else {
                  for {set ix $index} { $ix <= $octval} {incr ix} {
                     if {[llength $temp] < 8} {
                        lappend temp "0000"
                     }
                  }

                  if {$octlen == 3 && $lastoct > 0} {
                     set index $octval
                  }
               }
            }
            set retval [join $temp ":"]
         } else {
            set retval $address
         }
      } else {
         netaddr::_error "Invalid IP address: $address"
      }
   } else {
      netaddr::_error "No IP version defined!"
   }

   return $retval
}

# Get the IP version by doing some sanity checks and determines the version
proc netaddr::_getversion address {
   set retval 0
   set temp [split $address ':']
   set last [lindex $temp [expr [llength $temp] - 1]]
   set value [string first . $last]

   if {$value > 0} {
      set retval 4
   } else {
      set retval 6
   }

   return $retval
}

proc netaddr::_getsize { number {version 0} {wildcard 0}} {
   set retval 0
   if {[string is digit $number] == 1 && $number > 0} {
      set maxval 0
      if {$version == 4} {
         set ipvalmax 32
         set maxval [expr [expr 2 << 31] - 1]
         if {$maxval <= 0} {
            global maxinteger
            set maxval [expr $maxinteger - 1]
         }
      } elseif {$version == 6} {
         set ipvalmax 128
         set maxval [expr [expr 2 << 127] - 1]
         if {$maxval <= 0} {
            global maxlong
            set maxval [expr $maxlong - 1]
         }
      } 

      if {$number > $ipvalmax} {
         netaddr::_error "Netmask cannot be greater than 32"
      } elseif {$number <= 0 } {
         netaddr::_error "Netmask cannot be less than or equal to zero"
      } else {
         set operator [expr $ipvalmax - $number]
         set maskval [expr 1 << $operator]

         if {$wildcard == 1} {
            set retval [expr [expr 0 ^ $maskval] - 1]
         } else {
            set retval [expr [expr $maxval ^ $maskval] + 1]
         }
      }
   }

   return $retval
}

proc netaddr::_determine network {
   set version [netaddr::getversion]
   set retval 0
   if {[string length $network]} {
      set maxsubnet [netaddr::_getmaxsubnet]
      set var [split $network /]
      set varlen [llength $var]
      set ip [lindex $var 0]
      set subnet 0

      if {$varlen == 2} {
         set subnet [lindex $var 1]
      } elseif {$varlen == 1} {
         set subnet $maxsubnet
      }

      set address [netaddr::pton [netaddr::_normalize $ip $version] $version]
      set myaddr [netaddr::ip2integer]
      set bcast [netaddr::getbroadcast]
      set nlen [expr 1 << [expr $maxsubnet - $subnet]]
      set ncast [expr $address + [expr $nlen - 1]]

      if {$address <= $myaddr && $ncast >= $bcast} {
         set retval 1
      }
   }

   return $retval
}

proc netaddr::_getmaxsubnet {} {
   set version [netaddr::getversion]
   set retval 0
   if {$version == 4} {
      set retval 32
   } elseif {$version == 6} {
      set retval 128
   }

   return $retval
}

proc netaddr::_compress hextets {
   set address ""
   if {[llength $hextets] == 8} {
      set start -1
      set end -1
      set bstart -1
      set bend -1
      set count 0

      set nhextets [list]
      foreach ix $hextets {
         set value [format "%d" [expr 0x$ix & 0xFFFF]]
         if {$value == 0} {
            if {$start == -1} {
               set start $count
            }

            if {$start >= 0} {
               set end $count
               set bstart $start
               set bend $end
            }
         } else {
            if {$start >= 0} {
               set start -1
            }

            if {$end >= 0} {
               set end -1
            }
         }

         lappend nhextets [format "%x" $value]
         incr count
      }

      set address [join [lreplace $nhextets $bstart $bend ""] :]
      if {[string length $address] == 0} {
         set address "::"
      } else {
         if {[string index $address end] == ":"} {
            set address [concat "$address:"]
         } elseif {[string index $address 0] == ":"} {
            set address [concat ":$address"]
         }
      }
   }

   return [string tolower $address]
}

proc netaddr::ip { subnet { prefix 0 } { version 0 } } {
   variable _ipaddr 
   variable _ipver
   variable _ipinteger
   variable _completeaddr
   variable _ifscope

   set digit 0
   if {[string is digit -strict $subnet] == 1} {
      set digit 1
      variable _ipsubnet
      if {[string length $version] > 0} {
         if {$version == 4 || $version == 6} {
            variable _ipver $version
         } else {
            netaddr::_error "Invalid IP version provided: $version"
         }
      }

      variable _ipver [netaddr::_getversion [netaddr::ntop $subnet $version]]

      if {[string length $prefix] > 0} {
         set _ipsubnet $prefix
      } else {
         set _ipsubnet [netaddr::_getmaxsubnet]
      }

      set _completeaddr [netaddr::_normalize [
         netaddr::ntop $subnet $_ipver] $_ipver]
      set _ipinteger $subnet
   } else {
      variable _ipsubnet
      set var [split $subnet "/"]
      set scope ""
      regexp % $subnet scope
      if {[string length $scope]} {
         set temp [split [lindex $var 0] %]
         set ip [lindex $temp 0]
         variable _ifscope [lindex $temp 1]
      } else {
         set ip [lindex $var 0]
         variable _ifscope ""
      }

      set netlen [lindex $var 1]

      variable _ipver [netaddr::_getversion $ip]
      if {[string length $netlen] <= 0} {
         set _ipsubnet [netaddr::_getmaxsubnet]
      } else {
         set _ipsubnet $netlen
      }

      set _completeaddr [netaddr::_normalize $ip $_ipver]
      set _ipinteger [netaddr::pton $_completeaddr $_ipver]
   }

   if {[string length $_completeaddr]} {
      if {$_ipver == 6} {
         set _ipaddr [netaddr::_compress [split $_completeaddr :]]
      } else {
         if {$digit} {
            set _ipaddr $_completeaddr
         } else {
            set _ipaddr $ip
         }
      }
   }

   if {[string length $_ipsubnet]} {
      if {$_ipver == 4 && $_ipsubnet != 32} {
         set _ipaddr [concat $_ipaddr/$_ipsubnet]
      } elseif {$_ipver == 6 && $_ipsubnet != 128} {
         set _ipaddr [concat $_ipaddr/$_ipsubnet]
      }
   }

   variable _ipmask
   variable _ipwcard
   if {$_ipver == 4} {
      set _ipmask [netaddr::netmask $_ipsubnet $_ipver 0]
      set _ipwcard [netaddr::netmask $_ipsubnet $_ipver 1]
   } else {
      set _ipmask [netaddr::netmask $_ipsubnet $_ipver 0]
      set _ipwcard ""
   }

   global maxinteger
   global maxlong
   variable _ipsize

   set size [netaddr::_getsize $_ipsubnet $_ipver]
   if {$_ipver == 4} {
      set _ipsize [expr $maxinteger - $size]
   } elseif {$_ipver == 6} {
      set _ipsize [expr $maxlong - $size]
   }
}

proc netaddr::ip2integer {} {
   variable _ipinteger
   return $_ipinteger
}

proc netaddr::getmask {} {
   variable _ipmask
   return $_ipmask
}

proc netaddr::getwildcard {} {
   variable _ipwcard
   return $_ipwcard
}

proc netaddr::isnetwork {} {
   variable _ipsubnet 
   variable _ipver
   set retval 1
   if {$_ipver == 4 && $_ipsubnet == 32} {
      set retval 0
   } elseif {$_ipver == 6 && $_ipsubnet == 128} {
      set retval 0
   }

   return $retval
}

proc netaddr::pton { address { version 0 } } {
   set retval 0
   if {$version == 4} {
      set count 0
      foreach octet [split $address "."] {
         if {$count == 0} {
            set retval [expr $retval | [expr $octet << 24]]
         } elseif {$count == 1} {
            set retval [expr $retval | [expr $octet << 16]]
         } elseif {$count == 2} {
            set retval [expr $retval | [expr $octet << 8]]
         } elseif {$count == 3} {
            set retval [expr $retval | $octet]
         }               
         
         incr count      
      }
   } elseif {$version == 6} {
      foreach rec [split $address ":"] {
         set retval [expr [expr $retval << 16] + [netaddr::_hex2int $rec]]
      }
   }

   return $retval
}

proc netaddr::ntop {value version} {
   global maxinteger
   set retval ""

   if {$version == 4} {
      set range [list 1 2 3 4]
      set var [list]
      if {$value > $maxinteger} {
         netaddr::_error "Invalid integer value '$integer' to unpack"
      }

      foreach ix $range {
         lappend var [expr $value & 0xff]
         set value [expr $value >> 8]
      }

      set retval [join [lreverse $var] "."]
   } elseif {$version == 6} {
      set hextet1 ""
      set hextet2 ""
      set hextet3 ""
      set hextet4 ""
      foreach ix [list 1 2 3 4] {
         if {$ix == 1} {
            set hextet1 [expr [expr $value >> 64] >> 32]
         } elseif {$ix == 2} {
            set hextet2 [expr [expr $value >> 64] % $maxinteger]
         } elseif {$ix == 3} {
            set hextet3 [expr [expr $value >> 32] % $maxinteger]
         } elseif {$ix == 4} {
            set hextet4 [expr $value % $maxinteger]
         }
      }

      set hextets [list [format %x $hextet1] [format %x $hextet2] [
         format %x $hextet3] [format %x $hextet4]]
      set temp ""
      foreach hextet $hextets {
         set strlen [expr 8 - [string length $hextet]]
         if {$strlen > 0} {
            for {set ix 0} {$ix < $strlen} {incr ix} {
               set hextet [concat 0$hextet]
            }
         }

         set temp [concat $temp$hextet]
      }

      set count 1
      foreach ix [split $temp {}] {
         set retval [concat $retval$ix]
         if {$count != 32 && [expr $count % 4] == 0} {
            set retval [concat $retval:]
         }
         incr count
      }
   }

   return $retval
}

proc netaddr::getversion {} {
   variable _ipver
   return $_ipver
}

proc netaddr::getaddress {} {
   variable _ipaddr
   return $_ipaddr
}

proc netaddr::netmask { number { version 0 } { wildcard 0 } } {
   set retval ""
   if {$version == 4} {
      set bits [netaddr::_getsize $number $version $wildcard]
      set retval [netaddr::ntop $bits $version]
   } elseif {$version == 6} {
      if {$wildcard == 0} {
         set bits [netaddr::_getsize $number $version $wildcard]
         set retval [netaddr::ntop $bits $version]
      } else {
         netaddr::_warn "No wildcard for IPv6!"
      }
   }

   return $retval
}

proc netaddr::getsize {} {
   variable _ipsize
   return $_ipsize
}

proc netaddr::getnetwork {} {
   set version [netaddr::getversion]
   set mask [netaddr::pton [netaddr::getmask] $version]
   return [expr [netaddr::ip2integer] & $mask]
}

proc netaddr::getbroadcast {} {
   variable _ipsubnet 
   set maxval [netaddr::_getmaxsubnet]
   set size [expr 1 << [expr $maxval - $_ipsubnet]]
   return [expr [netaddr::getnetwork] + [expr $size - 1]]
}

proc netaddr::contains { child { ipver 0 } { prefix 0 } } {
   set retval 0
   if {[string length $child]} {
      set version 0
      set subnet 0
      set caddr 0

      set isdigit [string is digit -strict $child]
      if {$isdigit} {
         set version [netaddr::_getversion [netaddr::ntop $child $ipver]]
         if {$ipver != $version} {
            netaddr::_error "Mismatch of version given contrasts to finding!"
         }
         set caddr $child
         set subnet $prefix
      } else {
         set var [split $child /]
         set varlen [llength $var]
         set ip [lindex $var 0]
         set version [netaddr::_getversion $ip]
         if {$varlen == 2} { 
            set subnet [lindex $var 1]
         }

         set caddr [netaddr::pton [netaddr::_normalize $ip $version] $version]
      }

      set maxsubnet 0
      if {$version == 4} {
         set maxsubnet 32
      } elseif {$version == 6} {
         set maxsubnet 128
      }

      set maxval 0
      if {$version == 4} {
         global maxinteger
         set maxval [expr $maxinteger - 1]
      } elseif {$version == 6} {
         global maxlong
         set maxval [expr $maxlong - 1]
      }

      if {$subnet < 0 || $subnet > $maxsubnet} {
         netaddr::_error "Invalid prefix $child"
      } elseif {$subnet == 0} {
         set subnet $maxsubnet
      }

      set pversion [netaddr::getversion]
      if {$version == $pversion} {
         set bcast [netaddr::getbroadcast]
         set parent [netaddr::getnetwork]

         set nlen [expr 1 << [expr $maxsubnet - $subnet]]
         set ncast [expr $caddr + [expr $nlen - 1]]
         if {$parent <= $caddr && $bcast >= $ncast} {
            set retval 1
         }
      }
   }

   return $retval
}

proc netaddr::isloopback {} {
   set version [netaddr::getversion]
   set retval 0
   if {$version == 4} {
      set retval [netaddr::_determine "127.0.0.0/8"]
   } elseif {$version == 6} {
      variable _ipsubnet
      if {[netaddr::ip2integer] == 1 && $_ipsubnet == 128} {
         set retval 1
      }
   }

   return $retval
}

proc netaddr::ismulticast {} {
   set version [netaddr::getversion]
   set retval ""
   if {$version == 4} {
      set retval "224.0.0.0/4"
   } elseif {$version == 6} {
      set retval "ff00::/8"
   }

   return [netaddr::_determine $retval]

}

proc netaddr::islinklocal {} {
   set version [netaddr::getversion]
   set retval ""
   if {$version == 4} {
      set retval "169.254.0.0/16"
   } elseif {$version == 6} {
      set retval "fe80::/10"
   }

   return [netaddr::_determine $retval]
}

proc netaddr::ifscope {} {
   variable _ifscope
   return $_ifscope
}

proc netaddr::isunspecified {} {
   set version [netaddr::getversion]
   set retval 0
   if {$version == 4} {
      set retval [netaddr::_determine "0.0.0.0/8"]
   } elseif {$version == 6} {
      variable _ipsubnet
      if {[netaddr::ip2integer] == 0 && $_ipsubnet == 128} {
         set retval 1
      }
   }

   return $retval
}

proc netaddr::isreserved {} {
   set version [netaddr::getversion]
   set retval 0
   if {$version == 4} {
      set retval [netaddr::_determine "240.0.0.0/4"]
   } elseif {$version == 6} {
      set nets [list "::/8" "100::/8" "200::/7" "400::/6" "800::/5"  \
         "1000::/4" "4000::/3" "6000::/3" "8000::/3" "A000::/3"      \
         "C000::/3" "E000::/3" "F000::/5" "F800::/6" "FE00::/9"]
      foreach network $nets {
         set retval [expr $retval | [netaddr::_determine $network]]
      }
   }

   return $retval

}

proc netaddr::subnets value {
   variable _ipsubnet
   set version [netaddr::getversion]
   set retval [list]
   if {[string is integer -strict $value]} {
      set maxval [netaddr::_getmaxsubnet]
      if {$value > $maxval || $value < $_ipsubnet} {
         netaddr::_error "Invalid subnet value: $value"
      } else {
         if {[netaddr::isnetwork]} {
            set network [netaddr::getnetwork]
            set size [netaddr::getsize]
            set rsize [expr 1 << [expr $maxval - $value]]
            set count [expr $size / $rsize]
            for {set ix 0} {$ix < $count} {incr ix} {
               set address [netaddr::ntop $network $version]
               if {$version == 6} {
                  set address [netaddr::_compress [split $address :]]
               }
               lappend retval [concat $address/$value]
               set network [expr $network + $rsize]
            }
         } else {
            lappend retval [netaddr::getaddress]
         }
      }
   } else {
      netaddr::_error "Subnet value should be integer!"
   }

   return $retval
}

proc netaddr::completeip {} {
   variable _completeaddr
   return $_completeaddr
}

proc netaddr::debug flag {
   variable _debug 
   if {$flag == 1} {
      variable _debug 1
   } else {
      variable _debug 0
   }
}

proc netaddr::? {} { lsort [info procs ::netaddr::*] }
package provide netaddr $netaddr::version
